home *** CD-ROM | disk | FTP | other *** search
/ Enter 2004 January / enter-2004-01.iso / files / maxima-5.9.0.exe / {app} / share / maxima / 5.9.0 / src / mdefun.lisp < prev    next >
Encoding:
Text File  |  2003-02-09  |  7.3 KB  |  242 lines
  1. ;;; -*-  Mode: Lisp; Package: Maxima; Syntax: Common-Lisp; Base: 10 -*- ;;;;
  2. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  3. ;;;     The data in this file contains enhancments.                    ;;;;;
  4. ;;;                                                                    ;;;;;
  5. ;;;  Copyright (c) 1984,1987 by William Schelter,University of Texas   ;;;;;
  6. ;;;     All rights reserved                                            ;;;;;
  7. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  8. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  9. ;;;          Compilation environment for TRANSLATED MACSYMA code.        ;;;
  10. ;;;       (c) Copyright 1980 Massachusetts Institute of Technology       ;;;
  11. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  12.  
  13. (in-package "MAXIMA")
  14. (macsyma-module mdefun macro)
  15.  
  16. ;(TRANSL-MODULE MDEFUN) IS CORRECT. But doesn't work in the MPRELU
  17. ;; environment.
  18.  
  19. (load-macsyma-macros transm)
  20.  
  21. ;;; $FIX_NUM_ARGS_FUNCTION $VARIABLE_NUM_ARGS_FUNCTION.
  22.  
  23. (DEFVAR *KNOWN-FUNCTIONS-INFO-STACK* NIL
  24.   "When MDEFUN-TR expands it puts stuff here for MFUNCTION-CALL
  25.   to use.")
  26.  
  27. (DEFVAR *UNKNOWN-FUNCTIONS-INFO-STACK* NIL
  28.   "When MFUNCTION-CALL expands without info from
  29.   *KNOWN-FUNCTIONS-INFO-STACK* it puts stuff here to be barfed
  30.   at the end of compilation.")
  31.  
  32.  
  33. (DEFmacro MDEFUN-TR (&rest FORM)
  34.   (MAXIMA-ERROR "obsolete macro form, please retranslate source code"
  35.      form 'fail-act))
  36.  
  37. (DEFmacro MDEFUN (&rest FORM)
  38.   (MAXIMA-ERROR "obsolete macro form, please retranslate source code"
  39.      form 'fail-act))
  40.  
  41. ;;; DEFMTRFUN will be the new standard.
  42. ;;; It will punt macsyma fexprs since the macro scheme is now
  43. ;;; available. I have tried to generalize this enough to do
  44. ;;; macsyma macros also.
  45.  
  46. ;;; (DEFMTRFUN-EXTERNAL ($FOO <mode> <property> <&restp>))
  47.  
  48.  
  49. #+PDP10
  50. (DEFUN COMPILER-STATE () COMPILER-STATE)
  51. #+CL
  52. (DEFUN COMPILER-STATE () (Y-OR-N-P "Is COMPILER-STATE true?"))
  53. #-(OR CL PDP10) 
  54. (DEFUN COMPILER-STATE () T)
  55. #-cl ;is this used.??
  56. (defmacro defmtrfun-external ((name mode prop &rest restp))
  57.     #+pdp10
  58.     (and (eq prop 'mdefine) (COMPILER-STATE)
  59.      (PUSH-INFO NAME (COND (RESTP 'LEXPR)
  60.                    (T 'EXPR))
  61.             *KNOWN-FUNCTIONS-INFO-STACK*))
  62.     #-(or cl NIL)
  63.     `(declare (,(cond (restp '*lexpr) (t '*expr))
  64.            ,name)
  65.           ;; FLONUM declaration is most important
  66.           ;; for numerical work on the pdp-10.
  67.           ,@(IF (AND (EQ PROP 'MDEFINE) (EQ MODE '$FLOAT))
  68.             `((FLONUM (,NAME))))
  69.     ))
  70.  
  71. #+cl  ;;we don't make function type declarations yet.
  72. (defmacro defmtrfun-external (&rest ig) ig nil)
  73.  
  74. ;;; (DEFMTRFUN ($FOO <mode> <property> <&restp>) <ARGL> . BODY)
  75. ;;; If the MODE is numeric it should do something about the
  76. ;;; numebr declarations for compiling. Also, the information about the
  77. ;;; modes of the arguments should not be thrown away.
  78.  
  79. ;;; For the LISPM this sucks, since &REST is built-in.
  80. #+cl
  81. (DEfmacro DEFMTRFUN  ((NAME MODE PROP RESTP . ARRAY-FLAG) ARGL . BODY )
  82.   (let ((    DEF-HEADER))
  83.      (AND ARRAY-FLAG
  84.      ;; old DEFMTRFUN's might have this extra bit NIL
  85.      ;; new ones will have (NIL) or (T)
  86.      (SETQ ARRAY-FLAG (CAR ARRAY-FLAG)))
  87.     
  88.     (SETQ DEF-HEADER
  89.       (COND ((EQ PROP 'MDEFINE)
  90.          (COND (ARRAY-FLAG #-CL `(,NAME A-EXPR #+MACLISP A-SUBR)
  91.                    #+CL `(:PROPERTY ,NAME A-SUBR))
  92.                (T NAME)))
  93.         (T `(,NAME TRANSLATED-MMACRO))))
  94.     #+PDP10
  95.     (AND (EQ PROP 'MDEFINE) (COMPILER-STATE) (NOT ARRAY-FLAG)
  96.      (PUSH-INFO NAME (COND (RESTP 'LEXPR)
  97.                    (T 'EXPR))
  98.             *KNOWN-FUNCTIONS-INFO-STACK*))
  99.     
  100.     `(EVAL-WHEN (COMPILE EVAL LOAD)
  101.         ,@(AND (NOT ARRAY-FLAG) `((REMPROP ',NAME 'TRANSLATE)))
  102.         ,@(AND MODE `((DEFPROP ,NAME ,MODE
  103.                 ,(COND (ARRAY-FLAG 'ARRAYFUN-MODE)
  104.                    (T 'FUNCTION-MODE)))))
  105.         ,@(COND (ARRAY-FLAG
  106.              ;; when loading in hashed array properties
  107.              ;; most exist or be created. Other
  108.              ;; array properties must be consistent if
  109.              ;; they exist.
  110.              `((INSURE-ARRAY-PROPS ',NAME ',MODE
  111.                        ',(LENGTH ARGL)))))
  112.         ,@(COND ((AND (EQ PROP 'MDEFINE) (NOT ARRAY-FLAG))
  113.              `((COND ((STATUS FEATURE MACSYMA)
  114.                   (mputprop ',name t
  115.                     ,(COND
  116.                        ((NOT RESTP)
  117.                         ''$fixed_num_args_function)
  118.                        (T
  119.                         ''$variable_num_args_function)))))
  120.                ,(COND ((NOT RESTP)
  121.                    `(ARGS ',NAME '(NIL . ,(LENGTH ARGL))))))))
  122.         (,(if (consp def-header) 'DEFUN-prop 'defmfun)
  123.          ,DEF-HEADER ,(COND ((NOT RESTP) ARGL)
  124.                       (T '|mlexpr NARGS|))
  125.           ,@(COND ((NOT RESTP)
  126.                BODY)
  127.               (t
  128.                (LET ((NL (f1- (LENGTH ARGL))))
  129.              `((COND ((< |mlexpr NARGS| ,NL)
  130.                   ($ERROR
  131.                     'MAXIMA-ERROR ',NAME
  132.                     '| takes no less than |
  133.                     ,NL
  134.                     ',(COND ((= NL 1)
  135.                          '| argument.|)
  136.                         (T
  137.                          '| arguments.|))))
  138.                  (T
  139.                   ((LAMBDA ,ARGL
  140.                      ,@BODY)
  141.                    ;; this conses up the
  142.                    ;; calls to ARGS and LISTIFY.
  143.                    ,@(DO ((J 1 (f1+ J))
  144.                       (P-ARGL NIL))
  145.                      ((> J NL)
  146.                       (PUSH
  147.                         `(CONS
  148.                            '(MLIST)
  149.                            (LISTIFY
  150.                          (f- ,NL
  151.                             |mlexpr NARGS|)))
  152.                         P-ARGL)
  153.                       (NREVERSE P-ARGL))
  154.                        (PUSH `(ARG ,J)
  155.                          P-ARGL)))))))))))))
  156.  
  157.  
  158.  
  159.  
  160. #-cl
  161. (DEFUN-prop (DEFMTRFUN MACRO) (FORM)
  162.   (LET (( ((NAME MODE PROP RESTP . ARRAY-FLAG) ARGL . BODY) (CDR FORM))
  163.     (DEF-HEADER))
  164.     
  165.     (AND ARRAY-FLAG
  166.      ;; old DEFMTRFUN's might have this extra bit NIL
  167.      ;; new ones will have (NIL) or (T)
  168.      (SETQ ARRAY-FLAG (CAR ARRAY-FLAG)))
  169.  
  170.     (SETQ DEF-HEADER
  171.       (COND ((EQ PROP 'MDEFINE)
  172.          (COND (ARRAY-FLAG #-CL `(,NAME A-EXPR #+MACLISP A-SUBR)
  173.                    #+CL `(:PROPERTY ,NAME A-SUBR))
  174.                (T NAME)))
  175.         (T `(,NAME TRANSLATED-MMACRO))))
  176.     #+PDP10
  177.     (AND (EQ PROP 'MDEFINE) (COMPILER-STATE) (NOT ARRAY-FLAG)
  178.      (PUSH-INFO NAME (COND (RESTP 'LEXPR)
  179.                    (T 'EXPR))
  180.             *KNOWN-FUNCTIONS-INFO-STACK*))
  181.     
  182.     `(EVAL-WHEN (COMPILE EVAL LOAD)
  183.         ,@(AND (NOT ARRAY-FLAG) `((REMPROP ',NAME 'TRANSLATE)))
  184.         ,@(AND MODE `((DEFPROP ,NAME ,MODE
  185.                 ,(COND (ARRAY-FLAG 'ARRAYFUN-MODE)
  186.                    (T 'FUNCTION-MODE)))))
  187.         ,@(COND (ARRAY-FLAG
  188.              ;; when loading in hashed array properties
  189.              ;; most exist or be created. Other
  190.              ;; array properties must be consistent if
  191.              ;; they exist.
  192.              `((INSURE-ARRAY-PROPS ',NAME ',MODE
  193.                        ',(LENGTH ARGL)))))
  194.         ,@(COND ((AND (EQ PROP 'MDEFINE) (NOT ARRAY-FLAG))
  195.              `((COND ((STATUS FEATURE MACSYMA)
  196.                   (mputprop ',name t
  197.                     ,(COND
  198.                       ((NOT RESTP)
  199.                        ''$fixed_num_args_function)
  200.                       (T
  201.                        ''$variable_num_args_function)))))
  202.                ,(COND ((NOT RESTP)
  203.                    `(ARGS ',NAME '(NIL . ,(LENGTH ARGL))))))))
  204.         (,(if (consp def-header) 'DEFUN-prop 'defun)
  205.          ,DEF-HEADER ,(COND ((NOT RESTP) ARGL)
  206.                       (T '|mlexpr NARGS|))
  207.           ,@(COND ((NOT RESTP)
  208.                BODY)
  209.               (t
  210.                (LET ((NL (f1- (LENGTH ARGL))))
  211.              `((COND ((< |mlexpr NARGS| ,NL)
  212.                   ($ERROR
  213.                    'MAXIMA-ERROR ',NAME
  214.                    '| takes no less than |
  215.                    ,NL
  216.                    ',(COND ((= NL 1)
  217.                         '| argument.|)
  218.                        (T
  219.                         '| arguments.|))))
  220.                  (T
  221.                   ((LAMBDA ,ARGL
  222.                      ,@BODY)
  223.                    ;; this conses up the
  224.                    ;; calls to ARGS and LISTIFY.
  225.                    ,@(DO ((J 1 (f1+ J))
  226.                       (P-ARGL NIL))
  227.                      ((> J NL)
  228.                       (PUSH
  229.                        `(CONS
  230.                          '(MLIST)
  231.                          (LISTIFY
  232.                           (f- ,NL
  233.                          |mlexpr NARGS|)))
  234.                        P-ARGL)
  235.                       (NREVERSE P-ARGL))
  236.                        (PUSH `(ARG ,J)
  237.                          P-ARGL)))))))))))))
  238.  
  239.  
  240.  
  241.  
  242.